home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / basic.c < prev    next >
C/C++ Source or Header  |  1992-11-11  |  7KB  |  303 lines
  1. /* ******************************************************************** */
  2. /*  basic.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Basic functions                                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, April 1989
  10.  *      Add many functions - JPff
  11.  *      Add rplaca & rplacd - RJB
  12.  *      Add defmacro - JPff
  13.  *      Introduce GC protection in places - JPff
  14.  *    Wrote NREVERSE for fun - JPff
  15.  *    and ASSOC - JPff
  16.  *    Moved basic.c to generic.c - JPff
  17.  *    Add defconstant and mutability in bindings - JPff
  18.  *      Hacked car & cons on the nil case and fixed the consp 
  19.  *         make_module_function so that it didn't refer to cons !! - (25/10/89) KJP
  20.  *      Altered defun so that its body is a list of forms - (25/10/89) KJP
  21.  */
  22.  
  23. #include "defs.h"
  24. #include "structs.h"
  25. #include "funcalls.h"
  26.  
  27. #include "error.h"
  28. #include "global.h"
  29.  
  30. #include "modboot.h"
  31. #include "specials.h"
  32. #include "weak.h"
  33.  
  34. #ifdef WITH_SYS_TIMES
  35. #include <sys/times.h>
  36. #endif
  37.  
  38. EUFUN_1( Fn_atom, form)
  39. {
  40.   return (is_cons(form) ? nil : lisptrue);
  41. }
  42. EUFUN_CLOSE
  43.  
  44. void printoblist(LispObject *stacktop)
  45. {     /* Broke */
  46.   LispObject ob = (LispObject) ObList;
  47.   while (ob!=NULL) {
  48.     EUCALL_2(Fn_print,ob, StdErr);
  49.     ob = (LispObject) (ob->SYMBOL).left;
  50.   }
  51. }
  52.  
  53. EUFUN_0 (Fn_oblist)
  54. {
  55.   printoblist(stacktop);
  56.   return nil;
  57. }
  58. EUFUN_CLOSE
  59.  
  60. EUFUN_1( Fn_consn, n)
  61. {
  62.   int i;
  63.   LispObject l = nil;
  64.  
  65.   for (i = intval(n); i > 0; --i) {
  66.     ARG_1(stacktop) = l;
  67.     ARG_0(stacktop) = nil;
  68.     l = Fn_cons(stacktop);
  69.   }
  70.  
  71.   return(l);
  72. }
  73. EUFUN_CLOSE
  74.  
  75. EUFUN_1( Fn_system, str)
  76. {
  77.   extern int system(char *);
  78.  
  79.   if (!is_string(str))
  80.     CallError(stacktop,"system: not a string",str,NONCONTINUABLE);
  81.  
  82.   (void) system(stringof(str));
  83.  
  84.   return(nil);
  85. }
  86. EUFUN_CLOSE
  87.  
  88. EUFUN_1( Fn_getenv, str)
  89. {
  90.   extern char *getenv(char *);
  91.   extern int strlen(char *);
  92.   char *value;
  93.  
  94.   if (!is_string(str))
  95.     CallError(stacktop,"getenv: not a string",str,NONCONTINUABLE);
  96.  
  97.   value = getenv(stringof(str));
  98.  
  99.   if (value == NULL) return(nil);
  100.  
  101.   return((LispObject) allocate_string(stacktop,value,strlen(value)));
  102. }
  103. EUFUN_CLOSE
  104.  
  105. EUFUN_0( Fn_exit)
  106. {
  107.   fprintf(StdOut->STREAM.handle,"\n\nExiting EuLisp\n\n");
  108.   
  109.   system_lisp_exit(0);
  110.  
  111.   return(nil);
  112. }
  113. EUFUN_CLOSE
  114.  
  115. EUFUN_0( Fn_make_map)
  116. {
  117.   extern void make_description_file(LispObject *);
  118.  
  119.   make_description_file(stacktop);
  120.  
  121.   return(nil);
  122. }
  123. EUFUN_CLOSE
  124.  
  125. /* Time... */
  126.  
  127. #include <sys/types.h>
  128.  
  129. EUFUN_0( Fn_system_time)
  130. {
  131.   extern long time(long *);
  132.   long n;
  133.  
  134.   (void) time(&n);
  135.   return(allocate_integer(stackbase, (int) n));
  136. }
  137. EUFUN_CLOSE
  138.  
  139. EUFUN_0( Fn_process_id)
  140. {
  141.   extern int getpid(void);
  142.   int xx;
  143.   xx = getpid();
  144.   return(allocate_integer(stackbase,xx));
  145. }
  146. EUFUN_CLOSE
  147.  
  148. EUFUN_0( Fn_backtrace)
  149. {
  150.   extern void module_eval_backtrace(LispObject *);
  151.   module_eval_backtrace(stacktop);
  152.   return(nil);
  153. }
  154. EUFUN_CLOSE
  155.  
  156. EUFUN_0( Fn_cpu_time)
  157. {
  158.   extern long clock(void);
  159.   int xx;
  160.   xx=(int)(clock()/10000);
  161.   return(allocate_integer(stackbase,xx));
  162. }
  163. EUFUN_CLOSE
  164.  
  165. #ifdef WITH_SYS_TIMES
  166. EUFUN_0(Fn_sys_times)
  167. {
  168.   struct tms time_vals;
  169.   long total_time;
  170.   LispObject vals,tmp;
  171.   
  172.   total_time=times(&time_vals);
  173.   vals=allocate_vector(stacktop,3);
  174.   STACK_TMP(vals);
  175.   tmp=allocate_integer(stacktop,total_time);
  176.   UNSTACK_TMP(vals);
  177.   vref(vals,0)=tmp;
  178.   STACK_TMP(vals);
  179.   tmp=allocate_integer(stacktop,time_vals.tms_utime);
  180.   UNSTACK_TMP(vals);
  181.   vref(vals,1)=tmp;
  182.   STACK_TMP(vals);
  183.   tmp=allocate_integer(stacktop,time_vals.tms_stime);
  184.   UNSTACK_TMP(vals);
  185.   vref(vals,2)=tmp;
  186.   
  187.   return vals;
  188. }
  189. EUFUN_CLOSE
  190. #endif
  191.  
  192. EUFUN_0( Fn_rand)
  193. {
  194.   extern int rand(void);
  195.   int n;
  196.   n=rand();
  197.  
  198.   return(real_allocate_integer(stackbase, n));
  199. }
  200. EUFUN_CLOSE
  201.  
  202. EUFUN_1( Fn_srand, s)
  203. {
  204.   extern void srand(unsigned int);
  205.  
  206.   srand((unsigned int) intval(s));
  207.  
  208.   return(nil);
  209. }
  210. EUFUN_CLOSE
  211.  
  212. EUFUN_1( Fn_system_describe, obj)
  213. {
  214.   printf("Address: %x\n",(int) obj);
  215.   printf("Type: %x\n",typeof(obj));
  216.   printf("GC: %x\n",gcof(obj));
  217.   printf("Class: %x\n",(int) classof(obj));
  218.   fflush(stdout);
  219.   return(nil);
  220. }
  221. EUFUN_CLOSE
  222.  
  223. /* Weak pointers... */
  224.  
  225. extern LispObject allocate_weak_wrapper(LispObject*, LispObject);
  226.  
  227. EUFUN_1( Fn_make_weak_wrapper, obj)
  228. {
  229.   LispObject tmp;
  230.   tmp=EUCALL_2(Fn_cons,obj,nil);
  231.   lval_classof(tmp)=Weak_Wrapper;
  232.   lval_typeof(tmp)=TYPE_WEAK_WRAPPER;
  233.   return(tmp);
  234. }
  235. EUFUN_CLOSE
  236.  
  237. EUFUN_1( Fn_weak_wrapper_ref, w)
  238. {
  239.   if (!is_weak_wrapper(w))
  240.     CallError(stacktop,
  241.           "weak-wrapper-ref: not a weak wrapper",w,NONCONTINUABLE);
  242.  
  243.   return(weak_ptr_val(w));
  244. }
  245. EUFUN_CLOSE
  246.  
  247. EUFUN_2 (Fn_weak_wrapper_ref_setter, w, obj)
  248. {
  249.   if (!is_weak_wrapper(w))
  250.     CallError(stacktop,"(setter weak-wrapper-ref): not a weak wrapper",
  251.           w,NONCONTINUABLE);  
  252.  
  253.   weak_ptr_val(w) = obj;
  254.  
  255.   return(obj);
  256. }
  257. EUFUN_CLOSE
  258.  
  259. /* *************************************************************** */
  260. /* Initialisation of this section                                  */
  261. /* *************************************************************** */
  262.  
  263. void initialise_basic(LispObject *stacktop)
  264. {
  265.   LispObject get,set;
  266.   
  267.   (void) make_module_function(stacktop,"special-operator-p",Fn_special_form_p,1);
  268.   get = make_module_function(stacktop,"symbol-dynamic-value",Fn_dynamic,1);
  269.   STACK_TMP(get);
  270.   set = make_unexported_module_function(stacktop,"symbol-dynamic-value-updator",
  271.                     Fn_dynamic_setq,2);
  272.   UNSTACK_TMP(get);
  273.   set_anon_associate(stacktop,get,set);
  274.  
  275.   (void) make_module_function(stacktop,"atom",Fn_atom,1);
  276.   (void) make_module_function(stacktop,"oblist", Fn_oblist, 0);
  277.   (void) make_module_function(stacktop,"consn", Fn_consn, 1);
  278.   (void) make_module_function(stacktop,"system",Fn_system,1);
  279.   (void) make_module_function(stacktop,"getenv",Fn_getenv,1);
  280.   (void) make_module_function(stacktop,"exit",Fn_exit,0);
  281.   (void) make_module_function(stacktop,"make-map",Fn_make_map,0);
  282.   (void) make_module_function(stacktop,"system-time",Fn_system_time,0);
  283.   (void) make_module_function(stacktop,"process-id",Fn_process_id,0);
  284.   (void) make_module_function(stacktop,"backtrace",Fn_backtrace,0);
  285.   (void) make_module_function(stacktop,"cpu-time",Fn_cpu_time,0);
  286.   (void) make_module_function(stacktop,"c-rand",Fn_rand,0);
  287.   (void) make_module_function(stacktop,"c-srand",Fn_srand,1);
  288.  
  289.   (void) make_module_function(stacktop,"system-print",Fn_system_describe,1);
  290.  
  291.   (void) make_module_function(stacktop,"make-weak-wrapper",Fn_make_weak_wrapper,1);
  292.   get = make_module_function(stacktop,"weak-wrapper-ref",Fn_weak_wrapper_ref,1);
  293.   STACK_TMP(get);
  294.   set = make_module_function(stacktop,"(setter weak-wrapper-ref)",
  295.                  Fn_weak_wrapper_ref_setter,2);
  296.   UNSTACK_TMP(get);
  297.   set_anon_associate(stacktop,get,set);
  298.  
  299. #ifdef WITH_SYS_TIMES
  300.   (void) make_module_function(stacktop,"cpu-times",Fn_sys_times,0);
  301. #endif
  302. }
  303.